home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / shrlk201.zip / _SETUP.1 / nsShareLock.pas < prev    next >
Pascal/Delphi Source File  |  1997-07-22  |  28KB  |  739 lines
  1. unit nsShareLock;
  2.  
  3. { $DEFINE ActiveX}  // ActiveX = TCustomControl !ActiveX = TComponent
  4.  
  5. interface
  6.  
  7. uses
  8.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  9.   DsgnIntf, Registry;
  10.  
  11. const
  12.   DLLName                          = 'SHRLK20.DLL';
  13.   sl_OnInitialRun                  = WM_User + 0;
  14.   sl_OnCannotOpenRegistry          = WM_User + 1;
  15.   sl_OnWithinGracePeriod           = WM_User + 2;
  16.   sl_OnExtended                    = WM_User + 3;
  17.   sl_OnTriedToExtendAgain          = WM_User + 4;
  18.   sl_OnUnlocked                    = WM_User + 5;
  19.   sl_OnInvalidUnlockCodeEntered    = WM_User + 6;
  20.   sl_OnExceededTries               = WM_User + 7;
  21.   sl_OnRegistryModified            = WM_User + 8;
  22.   sl_OnWithinTrialPeriod           = WM_User + 9;
  23.   sl_OnTrialExpired                = WM_User + 10;
  24.   sl_OnClockMovedBack              = WM_User + 11;
  25.   sl_OnRegistered                  = WM_User + 12;
  26.   sl_OnUserUnlockCheck             = WM_User + 13;
  27.   sl_SuggestTerminate              = WM_User + 14;
  28.  
  29. type
  30.   TProtectType    = (ptNumberDays, ptSpecificDate, ptRunCount, ptNoExpire);
  31.   TStatusType     = (stTrialPeriod, stRegistered, stGracePeriod, stExpired);
  32.   TUserEncryptionEvent = procedure (UnlockCode, UserName, UserCompanyName: string; var ExtensionLength: integer; var GoodUnlockCode: Boolean) of object;
  33.   TUserExtensionEvent  = procedure (ExtensionLength: integer) of object;
  34.   TUserTerminateEvent  = procedure (Reason: integer) of object;
  35.  
  36. {$IFDEF ActiveX}
  37.   TnsShareLock = class(TCustomControl)
  38. {$ELSE}
  39.   TnsShareLock = class(TComponent)
  40. {$ENDIF}
  41.   private
  42. {$IFNDEF ActiveX}
  43.     //If we are deriving from TComponent then we have to make our own Handle
  44.     FSharelockHandle: HWND;
  45. {$ENDIF}
  46.     FRegistryLocation       : string;
  47.     FRegistryLocationBackup : string;
  48.     FsRegisteredTo          : string;
  49.     FsUnRegistered          : string;
  50.     FsRegistrationNumber    : string;
  51.     FsProgramVersion        : string;
  52.     FsCopyright             : string;
  53.  
  54.     FProtectType: TProtectType;
  55.     FTrialPeriodRemaining,
  56.     FTrialLength,
  57.     FGracePeriod,
  58.     FTries,
  59.     FOnTryNumber: integer;
  60.     FAbout,
  61.     FExpireDate,
  62.     FProductName,
  63.     FPrivateKey,
  64.     FCompanyName: string;
  65.     FUseDefaultDialogs: boolean;
  66.     FOnTrialExpired:               TNotifyEvent;
  67.     FOnWithinGracePeriod:          TNotifyEvent;
  68.     FOnUnlocked:                   TNotifyEvent;
  69.     FOnInvalidUnlockCodeEntered:   TNotifyEvent;
  70.     FOnClockMovedBack:             TNotifyEvent;
  71.     FOnWithinTrialPeriod:          TNotifyEvent;
  72.     FOnExceededTries:              TNotifyEvent;
  73.     FOnCannotOpenRegistry:         TNotifyEvent;
  74.     FOnRegistered:                 TNotifyEvent;
  75.     FOnRegistryModified:           TNotifyEvent;
  76.     FOnInitialRun:                 TNotifyEvent;
  77.     FOnTriedToExtendAgain:         TNotifyEvent;
  78.     FOnExtended:                   TUserExtensionEvent;
  79.     FOnUserUnlockCheck:            TUserEncryptionEvent;
  80.     FOnSuggestTerminate:           TUserTerminateEvent;
  81.  
  82.     procedure SetTries(Value: integer);
  83.     procedure SetProductName(Value: string);
  84.     procedure SetPrivateKey (Value: string);
  85.     procedure SetCompanyName(Value: string);
  86.     procedure SetGracePeriod(Value: integer);
  87.     procedure SetTrialLength(Value: integer);
  88.  
  89.     function ReturnTrialPeriodRemaining: integer;
  90.     function ReturnTryNumber: integer;
  91.     function ReturnExpirationDate: TDateTime;
  92.     function ReturnUserName: string;
  93.     function ReturnUserCompanyName: string;
  94.     function ReturnSerialNumber: string;
  95.     function ReturnStatus: TStatusType;
  96.     function ReturnDLLVersion: string;
  97.  
  98.   protected
  99.     {$IFDEF ActiveX}
  100.     procedure Paint; override;
  101.     {$ELSE}
  102.     procedure WndProc(var MessageIn: TMessage);
  103.     {$ENDIF}
  104.     procedure Received_OnInitialRun              (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnInitialRun;               {$ENDIF}
  105.     procedure Received_OnCannotOpenRegistry      (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnCannotOpenRegistry;       {$ENDIF}
  106.     procedure Received_OnWithinGracePeriod       (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnWithinGracePeriod;        {$ENDIF}
  107.     procedure Received_OnExtended                (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnExtended;                 {$ENDIF}
  108.     procedure Received_OnTriedToExtendAgain      (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnTriedToExtendAgain;       {$ENDIF}
  109.     procedure Received_OnUnlocked                (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnUnlocked;                 {$ENDIF}
  110.     procedure Received_OnInvalidUnlockCodeEntered(var Msg: TMessage); {$IFDEF ActiveX} message sl_OnInvalidUnlockCodeEntered; {$ENDIF}
  111.     procedure Received_OnExceededTries           (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnExceededTries;            {$ENDIF}
  112.     procedure Received_OnRegistryModified        (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnRegistryModified;         {$ENDIF}
  113.     procedure Received_OnWithinTrialPeriod       (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnWithinTrialPeriod;        {$ENDIF}
  114.     procedure Received_OnTrialExpired            (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnTrialExpired;             {$ENDIF}
  115.     procedure Received_OnClockMovedBack          (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnClockMovedBack;           {$ENDIF}
  116.     procedure Received_OnRegistered              (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnRegistered;               {$ENDIF}
  117.     procedure Received_OnUserUnlockCheck         (var Msg: TMessage); {$IFDEF ActiveX} message sl_OnUserUnlockCheck;          {$ENDIF}
  118.     procedure Received_SuggestTerminate          (var Msg: TMessage); {$IFDEF ActiveX} message sl_SuggestTerminate;           {$ENDIF}
  119.  
  120.   public
  121.     constructor Create(aOwner: TComponent); override;
  122.     destructor  Destroy; override;
  123.     property    TrialPeriodRemaining:        integer           read ReturnTrialPeriodRemaining;
  124.     property    TryNumber:                   integer           read ReturnTryNumber;
  125.     property    ExpirationDate:              TDateTime         read ReturnExpirationDate;
  126.     property    UserName:                    string            read ReturnUserName;
  127.     property    UserCompanyName:             string            read ReturnUserCompanyName;
  128.     property    SerialNum:                   string            read ReturnSerialNumber;
  129.     property    Status:                      TStatusType       read ReturnStatus;
  130.     property    DLLVersion:                  string            read ReturnDLLVersion;
  131.     function    DisplayAboutDialog:          boolean;
  132.     procedure   CheckProtection;
  133.     procedure   EnterUnlockCode(sUnlockCode, sUserName, sUserCompanyName: string);
  134.     procedure   DisplayRegistrationDialog;
  135.  
  136.   published
  137.     property RegistryLocation:           string               read FRegistryLocation           write FRegistryLocation;
  138.     property RegistryLocationBackup:     string               read FRegistryLocationBackup     write FRegistryLocationBackup;
  139.     property TrialLength:                integer              read FTrialLength                write SetTrialLength;
  140.     property Tries:                      integer              read FTries                      write SetTries;
  141.     property GracePeriod:                Integer              read FGracePeriod                write SetGracePeriod;
  142.     property Protection:                 TProtectType         read FProtectType                write FProtectType;
  143.     property ExpireDate:                 string               read FExpireDate                 write FExpireDate;
  144.     property ProgramName:                string               read FProductName                write SetProductName;
  145.     property PrivateKey:                 string               read FPrivateKey                 write SetPrivateKey;
  146.     property UseDefaultDialogs:          boolean              read FUseDefaultDialogs          write FUseDefaultDialogs;
  147.     property CompanyName:                string               read FCompanyName                write SetCompanyName;
  148.     property About:                      string               read FAbout                      write FAbout;
  149.     property OnTrialExpired:             TNotifyEvent         read FOnTrialExpired             write FOnTrialExpired;
  150.     property OnWithinGracePeriod:        TNotifyEvent         read FOnWithinGracePeriod        write FOnWithinGracePeriod;
  151.     property OnUnlocked:                 TNotifyEvent         read FOnUnlocked                 write FOnUnlocked;
  152.     property OnInvalidUnlockCodeEntered: TNotifyEvent         read FOnInvalidUnlockCodeEntered write FOnInvalidUnlockCodeEntered;
  153.     property OnClockMovedBack:           TNotifyEvent         read FOnClockMovedBack           write FOnClockMovedBack;
  154.     property OnWithinTrialPeriod:        TNotifyEvent         read FOnWithinTrialPeriod        write FOnWithinTrialPeriod;
  155.     property OnExceededTries:            TNotifyEvent         read FOnExceededTries            write FOnExceededTries;
  156.     property OnRegistered:               TNotifyEvent         read FOnRegistered               write FOnRegistered;
  157.     property OnRegistryModified:         TNotifyEvent         read FOnRegistryModified         write FOnRegistryModified;
  158.     property OnCannotOpenRegistry:       TNotifyEvent         read FOnCannotOpenRegistry       write FOnCannotOpenRegistry;
  159.     property OnInitialRun:               TNotifyEvent         read FOnInitialRun               write FOnInitialRun;
  160.     property OnTriedToExtendAgain:       TNotifyEvent         read FOnTriedToExtendAgain       write FOnTriedToExtendAgain;
  161.     property OnExtended:                 TUserExtensionEvent  read FOnExtended                 write FOnExtended;
  162.     property OnUserUnlockCheck:          TUserEncryptionEvent read FOnUserUnlockCheck          write FOnUserUnlockCheck;
  163.     property OnSuggestTerminate:         TUserTerminateEvent  read FOnSuggestTerminate         write FOnSuggestTerminate;
  164.  
  165.     property About_RegisteredTo:         string               read FsRegisteredTo              write FsRegisteredTo;
  166.     property About_UnRegistered:         string               read FsUnRegistered              write FsUnRegistered;
  167.     property About_RegistrationNumber:   string               read FsRegistrationNumber        write FsRegistrationNumber;
  168.     property About_ProgramVersion:       string               read FsProgramVersion            write FsProgramVersion;
  169.     property About_Copyright:            string               read FsCopyright                 write FsCopyright;
  170.   end;
  171.  
  172.   TnsShareLockAbout = class(TStringProperty)
  173.   public
  174.     function GetAttributes: TPropertyAttributes; override;
  175.     procedure Edit; override;
  176.   end;
  177.  
  178.   TnsShareLockDLLVersion = class(TStringProperty)
  179.   public
  180.     function GetAttributes: TPropertyAttributes; override;
  181.   end;
  182.  
  183.   TnsShareLockExpireDate = class(TStringProperty)
  184.   public
  185.     function GetAttributes: TPropertyAttributes; override;
  186.     procedure Edit; override;
  187.   end;
  188.  
  189.   TnsShareLockReg = class(TStringProperty)
  190.   public
  191.     function GetAttributes: TPropertyAttributes; override;
  192.     procedure Edit; override;
  193.   end;
  194.  
  195. procedure Register;
  196.  
  197.   procedure CheckProtectionDLL(
  198.   FRegistryLocationA,
  199.   FRegistryLocationB,
  200.   FProductName,
  201.   FCompanyName,
  202.   FExpireDate,
  203.   FPrivateKey: pchar;
  204.   FTrialLength,
  205.   FGracePeriod,
  206.   FTries,
  207.   FUseDefaultDialogs,
  208.   FProtectType: integer
  209.   ); stdcall; external DLLName name 'CheckProtectionDLL';
  210.  
  211.   function  GetTrialPeriodRemaining: integer;                                 stdcall; external DLLName name 'GetTrialPeriodRemaining';
  212.   function  GetTryNumber: integer;                                            stdcall; external DLLName name 'GetTryNumber';
  213.   function  GetExpirationDate: pchar;                                         stdcall; external DLLName name 'GetExpirationDate';
  214.   function  GetUserName: pchar;                                               stdcall; external DLLName name 'GetUserName';
  215.   function  GetUserCompanyName: pchar;                                        stdcall; external DLLName name 'GetUserCompanyName';
  216.   function  GetSerialNumber: pchar;                                           stdcall; external DLLName name 'GetSerialNumber';
  217.   procedure InputUnlockCode(sUnlockCode, sUserName, sUserCompanyName: pchar); stdcall; external DLLName name 'InputUnlockCode';
  218.   procedure PassHandle(AppHandle: THandle);                                   stdcall; external DLLName name 'PassHandle';
  219.   function  GetDLLVersion: pchar;                                             stdcall; external DLLName name 'GetDLLVersion';
  220.   procedure DoRegistration;                                                   stdcall; external DLLName name 'DoRegistration';
  221.   function  GetStatus: integer;                                               stdcall; external DLLName name 'GetStatus';
  222.   function  ShowAboutDialog(
  223.     FSVersion,
  224.     FsCopyright,
  225.     FsRegisteredTo,
  226.     FsUnRegistered,
  227.     FsRegistrationNumber,
  228.     AppFilename: pchar
  229.     ): boolean; stdcall; external DLLName name 'ShowAboutDialog';
  230.  
  231. implementation
  232.  
  233. uses nsDateEdit, nsRegPicker, nsUnlock, nsAbout;
  234.  
  235. procedure Register;
  236. begin
  237.   RegisterComponents('Nesbitt Software', [TnsShareLock]);
  238.   RegisterPropertyEditor(typeinfo(string), TnsShareLock, 'About',                  TnsShareLockAbout);
  239.   RegisterPropertyEditor(typeinfo(string), TnsShareLock, 'DLLVersion',             TnsShareLockDLLVersion);
  240.   RegisterPropertyEditor(typeinfo(string), TnsShareLock, 'ExpireDate',             TnsShareLockExpireDate);
  241.   RegisterPropertyEditor(typeinfo(string), TnsShareLock, 'RegistryLocation',       TnsShareLockReg);
  242.   RegisterPropertyEditor(typeinfo(string), TnsShareLock, 'RegistryLocationBackup', TnsShareLockReg);
  243. end;
  244.  
  245. constructor TnsShareLock.Create(AOwner: TComponent);
  246. begin
  247.   inherited Create(AOwner);
  248.   //Set the date to something that will remain constant.
  249.   ShortDateFormat := 'm"/"d"/"yyyy';
  250.   DateSeparator := '/';
  251.  
  252.   {$IFDEF ActiveX}
  253.   Width := 32;
  254.   Height := 32;
  255.   if not (csDesigning in ComponentState) then Visible := False;
  256.   TabStop := False;
  257.   {$ELSE}
  258.   FSharelockHandle := AllocateHWnd(WndProc);
  259.   {$ENDIF}
  260.  
  261.   FProtectType := ptNumberDays;
  262.   FRegistryLocation := 'HKEY_CURRENT_USER\Software\SampleLocation1';
  263.   FRegistryLocationBackup := 'HKEY_CURRENT_USER\Software\SampleLocation2';
  264.   FExpireDate := FormatDateTime('ddddd', Now);
  265.   FTrialLength := 30;
  266.   FTrialPeriodRemaining := -1;
  267.   FGracePeriod := 0;
  268.   FProductName := 'Program';
  269.   FPrivateKey := 'A1B2C3';
  270.   FCompanyName := 'Company';
  271.   FUseDefaultDialogs := True;
  272.   FTries := 3;
  273.   FOnTryNumber := 0;
  274.   FAbout := 'nsShareLock';
  275.   FsRegisteredTo       := 'This program is licensed to:';
  276.   FsUnregistered       := 'This program is unregistered.';
  277.   FsRegistrationNumber := 'Registration Number:';
  278.   FsCopyright          := 'Copyright 1997 My Software';
  279. end;
  280.  
  281. destructor TnsShareLock.Destroy;
  282. begin
  283.   {$IFNDEF ActiveX}
  284.   DeallocateHWnd(FSharelockHandle);
  285.   {$ENDIF}
  286.   inherited Destroy;
  287. end;
  288.  
  289. //////////////////////////////////////////////////////////////////
  290.  
  291. {$IFNDEF ActiveX}
  292. procedure TnsShareLock.WndProc(var MessageIn: TMessage);
  293. begin
  294.   case MessageIn.Msg of
  295.     sl_OnInitialRun:                Received_OnInitialRun (MessageIn);
  296.     sl_OnCannotOpenRegistry:        Received_OnCannotOpenRegistry (MessageIn);
  297.     sl_OnWithinGracePeriod:         Received_OnWithinGracePeriod (MessageIn);
  298.     sl_OnExtended:                  Received_OnExtended (MessageIn);
  299.     sl_OnTriedToExtendAgain:        Received_OnTriedToExtendAgain (MessageIn);
  300.     sl_OnUnlocked:                  Received_OnUnlocked (MessageIn);
  301.     sl_OnInvalidUnlockCodeEntered:  Received_OnInvalidUnlockCodeEntered (MessageIn);
  302.     sl_OnExceededTries:             Received_OnExceededTries (MessageIn);
  303.     sl_OnRegistryModified:          Received_OnRegistryModified (MessageIn);
  304.     sl_OnWithinTrialPeriod:         Received_OnWithinTrialPeriod (MessageIn);
  305.     sl_OnTrialExpired:              Received_OnTrialExpired (MessageIn);
  306.     sl_OnClockMovedBack:            Received_OnClockMovedBack (MessageIn);
  307.     sl_OnRegistered:                Received_OnRegistered (MessageIn);
  308.     sl_OnUserUnlockCheck:           Received_OnUserUnlockCheck (MessageIn);
  309.     sl_SuggestTerminate:            Received_SuggestTerminate (MessageIn);
  310.     else  MessageIn.Result := DefWindowProc(FSharelockHandle, MessageIn.Msg, MessageIn.wParam, MessageIn.lParam);
  311.   end;
  312. end;
  313. {$ENDIF}
  314.  
  315. //////////////////////////////////////////////////////////////////
  316. {$IFDEF ActiveX}
  317. procedure TnsShareLock.Paint;
  318. begin
  319.   Canvas.Brush.Color := clBtnFace;
  320.   Canvas.Font.Color := Canvas.Pen.Color;
  321.   Canvas.TextOut(5,5,'This application protected by ShareLock');
  322.   Width := Canvas.TextWidth('This application protected by ShareLock') + 10;
  323.   Height := Canvas.TextHeight('This application protected by ShareLock') + 10;
  324. end;
  325. {$ENDIF}
  326.  
  327. //////////////////////////////////////////////////////////////////
  328.  
  329. function TnsShareLockExpireDate.GetAttributes;
  330. begin
  331.   Result := [paDialog, paReadOnly];
  332. end;
  333.  
  334. //////////////////////////////////////////////////////////////////
  335.  
  336. procedure TnsShareLockExpireDate.Edit;
  337. var
  338.   DateForm :TfrmDate;
  339.   sDate: string;
  340.   Year, Month, Day: Word;
  341. begin
  342.   DateForm := TfrmDate.Create(Application);
  343.   try
  344.     DecodeDate(StrToDate(GetValue),Year, Month, Day);
  345.     sDate := DateForm.Execute(Year, Month, Day);
  346.     if sDate <> '' then SetValue(sDate);
  347.   finally
  348.     DateForm.Free;
  349.   end;
  350. end;
  351.  
  352. //////////////////////////////////////////////////////////////////
  353.  
  354. function TnsShareLockReg.GetAttributes;
  355. begin
  356.   Result := [paDialog, paReadOnly];
  357. end;
  358.  
  359. //////////////////////////////////////////////////////////////////
  360.  
  361. procedure TnsShareLockReg.Edit;
  362. var
  363.   RegForm :TfrmRegistry;
  364. begin
  365.   RegForm := TfrmRegistry.Create(Application);
  366.   try
  367.     if RegForm.ShowModal = mrOk then
  368.       begin
  369.         SetValue(RegForm.Key);
  370.       end;
  371.   finally
  372.     RegForm.Free;
  373.   end;
  374. end;
  375.  
  376. //////////////////////////////////////////////////////////////////
  377.  
  378. function TnsShareLock.DisplayAboutDialog: Boolean;
  379. begin
  380.   Result := ShowAboutDialog(
  381.     PChar(FsProgramVersion),
  382.     PChar(FsCopyright),
  383.     PChar(FsRegisteredTo),
  384.     PChar(FsUnRegistered),
  385.     PChar(FsRegistrationNumber),
  386.     PChar(Application.Exename)
  387.   );
  388. end;
  389.  
  390. //////////////////////////////////////////////////////////////////////
  391.  
  392. procedure TnsShareLock.SetTrialLength(Value:integer);
  393. begin
  394.   if Value <= 0 then Value := 1;
  395.   FTrialLength := Value;
  396. end;
  397.  
  398. //////////////////////////////////////////////////////////////////////
  399.  
  400. procedure TnsShareLock.SetTries(Value:integer);
  401. begin
  402.   if Value <= 0 then Value := 1;
  403.   FTries := Value;
  404. end;
  405.  
  406. //////////////////////////////////////////////////////////////////////
  407.  
  408. procedure TnsShareLock.SetProductName(Value: string);
  409. begin
  410.   if Value <> '' then FProductName := Value;
  411. end;
  412.  
  413. //////////////////////////////////////////////////////////////////////
  414.  
  415. procedure TnsShareLock.SetPrivateKey(Value: string);
  416. begin
  417.   if Value <> '' then FPrivateKey := Value;
  418. end;
  419.  
  420. //////////////////////////////////////////////////////////////////////
  421.  
  422. procedure TnsShareLock.SetCompanyName(Value: string);
  423. begin
  424.   if Value <> '' then FCompanyName := Value;
  425. end;
  426.  
  427. //////////////////////////////////////////////////////////////////////
  428.  
  429. procedure TnsShareLock.SetGracePeriod(Value:integer);
  430. begin
  431.   if Value < 0 then Value := 0;
  432.   FGracePeriod := Value;
  433. end;
  434.  
  435. //////////////////////////////////////////////////////////////////////
  436.  
  437. function TnsShareLockAbout.GetAttributes;
  438. begin
  439.   Result := [paMultiSelect, paDialog, paReadOnly];
  440. end;
  441.  
  442. //////////////////////////////////////////////////////////////////
  443.  
  444. procedure TnsShareLockAbout.Edit;
  445. var
  446.   frmnsAbout: TfrmnsAbout;
  447. begin
  448.   frmnsAbout := TfrmnsAbout.Create(Application);
  449.   try
  450.     frmnsAbout.ShowModal;
  451.   finally;
  452.     frmnsAbout.Free;
  453.   end;
  454. end;
  455.  
  456. //////////////////////////////////////////////////////////////////
  457.  
  458. function TnsShareLockDLLVersion.GetAttributes;
  459. begin
  460.   Result := [paMultiSelect, paReadOnly];
  461. end;
  462.  
  463. //////////////////////////////////////////////////////////////////
  464.  
  465. procedure TnsShareLock.CheckProtection;
  466. begin
  467.   //Send a handle to the DLL so that it can pass back messages
  468.   {$IFDEF ActiveX}
  469.   Passhandle(Handle);
  470.   {$ELSE}
  471.   PassHandle(FSharelockHandle);
  472.   {$ENDIF}
  473.  
  474.   //This is the key routine
  475.   CheckProtectionDLL(
  476.      pchar(FRegistryLocation),
  477.      pchar(FRegistryLocationBackup),
  478.      pchar(FProductName),
  479.      pchar(FCompanyName),
  480.      PChar(FormatDateTime('ddddd', StrToDate(FExpireDate))),
  481.      PChar(FPrivateKey),
  482.      FTrialLength,
  483.      FGracePeriod,
  484.      FTries,
  485.      integer(FUseDefaultDialogs),
  486.      ord(FProtectType)
  487.   );
  488. end;
  489.  
  490. //////////////////////////////////////////////////////////////////////
  491.  
  492. function TnsShareLock.ReturnTrialPeriodRemaining: integer;
  493. begin
  494.   Result := GetTrialPeriodRemaining;
  495. end;
  496.  
  497. //////////////////////////////////////////////////////////////////////
  498.  
  499. function TnsShareLock.ReturnTryNumber: integer;
  500. begin
  501.   Result := GetTryNumber;
  502. end;
  503.  
  504. //////////////////////////////////////////////////////////////////////
  505.  
  506. function TnsShareLock.ReturnExpirationDate: TDateTime;
  507. var
  508.   sTemp: string;
  509. begin
  510.   //for some reason GetExpiration sometimes append a null to the end of the string - erase it.
  511.   sTemp := GetExpirationDate;
  512.   sTemp[Length(sTemp)] := ' ';
  513.   Result := StrToDate(sTemp);
  514. end;
  515.  
  516. //////////////////////////////////////////////////////////////////////
  517.  
  518. function TnsShareLock.ReturnUserName: string;
  519. begin
  520.   Result := GetUserName;
  521. end;
  522.  
  523. //////////////////////////////////////////////////////////////////////
  524.  
  525. function TnsShareLock.ReturnUserCompanyName: string;
  526. begin
  527.   Result := GetUserCompanyName;
  528. end;
  529.  
  530. //////////////////////////////////////////////////////////////////////
  531.  
  532. function TnsShareLock.ReturnSerialNumber: string;
  533. begin
  534.   Result := GetSerialNumber;
  535. end;
  536.  
  537. //////////////////////////////////////////////////////////////////////
  538.  
  539. function TnsShareLock.ReturnDLLVersion: string;
  540. begin
  541.   Result := GetDLLVersion;
  542. end;
  543.  
  544. //////////////////////////////////////////////////////////////////////
  545.  
  546. function TnsShareLock.ReturnStatus: TStatusType;
  547. begin
  548.   case GetStatus of
  549.     0: Result := stTrialPeriod;
  550.     1: Result := stRegistered;
  551.     2: Result := stGracePeriod;
  552.     3: Result := stExpired;
  553.     else Result := stTrialPeriod;
  554.   end;
  555. end;
  556.  
  557. //////////////////////////////////////////////////////////////////////
  558.  
  559. procedure TnsShareLock.EnterUnlockCode(sUnlockCode, sUserName, sUserCompanyName: string);
  560. begin
  561.   InputUnlockCode(pchar(sUnlockCode), pchar(sUserName), pchar(sUserCompanyName));
  562. end;
  563.  
  564. //////////////////////////////////////////////////////////////////
  565.  
  566. procedure TnsShareLock.DisplayRegistrationDialog;
  567. begin
  568.   DoRegistration;
  569. end;
  570.  
  571. //////////////////////////////////////////////////////////////////
  572.  
  573. procedure TnsSharelock.Received_OnInitialRun(var Msg: TMessage);
  574. begin
  575.   if assigned(FOnInitialRun) then FOnInitialRun(Self);
  576. end;
  577.  
  578. //////////////////////////////////////////////////////////////////
  579.  
  580. procedure TnsSharelock.Received_OnCannotOpenRegistry(var Msg: TMessage);
  581. begin
  582.   if assigned(FOnCannotOpenRegistry) then FOnCannotOpenRegistry(Self);
  583. end;
  584.  
  585. //////////////////////////////////////////////////////////////////
  586.  
  587. procedure TnsSharelock.Received_OnWithinGracePeriod(var Msg: TMessage);
  588. begin
  589.   if assigned(FOnWithinGracePeriod) then FOnWithinGracePeriod(Self);
  590. end;
  591.  
  592. //////////////////////////////////////////////////////////////////
  593.  
  594. procedure TnsSharelock.Received_OnExtended(var Msg: TMessage);
  595. begin
  596.   if assigned(FOnExtended) then FOnExtended(Msg.wParam);
  597. end;
  598.  
  599. //////////////////////////////////////////////////////////////////
  600.  
  601. procedure TnsSharelock.Received_OnTriedToExtendAgain(var Msg: TMessage);
  602. begin
  603.   if assigned(FOnTriedToExtendAgain) then FOnTriedToExtendAgain(Self);
  604. end;
  605.  
  606. //////////////////////////////////////////////////////////////////
  607.  
  608. procedure TnsSharelock.Received_OnUnlocked(var Msg: TMessage);
  609. begin
  610.   if assigned(FOnUnlocked) then FOnUnlocked(Self);
  611. end;
  612.  
  613. //////////////////////////////////////////////////////////////////
  614.  
  615. procedure TnsSharelock.Received_OnInvalidUnlockCodeEntered(var Msg: TMessage);
  616. begin
  617.   if assigned(FOnInvalidUnlockCodeEntered) then FOnInvalidUnlockCodeEntered(Self);
  618. end;
  619.  
  620. //////////////////////////////////////////////////////////////////
  621.  
  622. procedure TnsSharelock.Received_OnExceededTries(var Msg: TMessage);
  623. begin
  624.   if assigned(FOnExceededTries) then FOnExceededTries(Self);
  625. end;
  626.  
  627. //////////////////////////////////////////////////////////////////
  628.  
  629. procedure TnsSharelock.Received_OnRegistryModified(var Msg: TMessage);
  630. begin
  631.   if assigned(FOnRegistryModified) then FOnRegistryModified(Self);
  632. end;
  633.  
  634. //////////////////////////////////////////////////////////////////
  635.  
  636. procedure TnsSharelock.Received_OnWithinTrialPeriod(var Msg: TMessage);
  637. begin
  638.   if assigned(FOnWithinTrialPeriod) then FOnWithinTrialPeriod(Self);
  639. end;
  640.  
  641. //////////////////////////////////////////////////////////////////
  642.  
  643. procedure TnsSharelock.Received_OnTrialExpired(var Msg: TMessage);
  644. begin
  645.   if assigned(FOnTrialExpired) then FOnTrialExpired(Self);
  646. end;
  647.  
  648. //////////////////////////////////////////////////////////////////
  649.  
  650. procedure TnsSharelock.Received_OnClockMovedBack(var Msg: TMessage);
  651. begin
  652.   if assigned(FOnClockMovedBack) then FOnClockMovedBack(Self);
  653. end;
  654.  
  655. //////////////////////////////////////////////////////////////////
  656.  
  657. procedure TnsSharelock.Received_OnRegistered(var Msg: TMessage);
  658. begin
  659.   if assigned(FOnRegistered) then FOnRegistered(Self);
  660. end;
  661.  
  662. //////////////////////////////////////////////////////////////////
  663.  
  664. procedure TnsSharelock.Received_OnUserUnlockCheck(var Msg: TMessage);
  665.  
  666.   function ParseToken(var str: string): string;
  667.   begin
  668.     if Pos('~', str) > 0 then
  669.       begin
  670.         Result := Copy(str, 1, Pos('~', str) - 1);
  671.         str := Copy (str, Pos('~', str) + 1, 1024);
  672.       end
  673.     else
  674.       begin
  675.         Result := str;
  676.         str := '';
  677.       end;
  678.   end;
  679.  
  680. var
  681.   sStringIn: string;
  682.   sUserName, sUserCompanyName, sUnlockCode: string;
  683.   iExtension: integer;
  684.   fGoodUnlockCode: boolean;
  685.  
  686. begin
  687.   sStringIn := StrPas(pChar(msg.lParam));
  688.   try
  689.     Msg.Result := 0;
  690.     sUserName := ParseToken(sStringIn);
  691.     sUnlockCode := ParseToken(sStringIn);
  692.     sUserCompanyName := ParseToken(sStringIn);
  693.     if msg.wParam = 0 then fGoodUnlockCode := False;
  694.     if msg.wParam = 1 then fGoodUnlockCode := True;
  695.  
  696.      //User defined routine
  697.       begin
  698.         iExtension := 0;
  699.         if Assigned(FOnUserUnlockCheck) then
  700.           begin
  701.             FOnUserUnlockCheck( sUnlockCode, sUserName, sUserCompanyName, iExtension, fGoodUnlockCode);
  702.             if fGoodUnlockCode then
  703.               begin
  704.                 if iExtension = 0 then Msg.Result := 366 else Msg.Result := iExtension;
  705.               end
  706.             else
  707.               begin
  708.                 Msg.Result := -1;
  709.               end;
  710.           end
  711.         else
  712.           begin
  713.             Msg.Result := 0;
  714.           end;
  715.       end;
  716.   except
  717.     //showmessage('An error occured while processing User Unlock Check');
  718.   end;
  719. end;
  720.  
  721. //////////////////////////////////////////////////////////////////
  722.  
  723. procedure TnsSharelock.Received_SuggestTerminate(var Msg: TMessage);
  724. begin
  725.   if Assigned(FOnSuggestTerminate) then
  726.     begin
  727.       case Msg.wParam of
  728.         1: //Exceeded Tries
  729.           FOnSuggestTerminate(1);
  730.         2: //CannotOpenRegistry
  731.           FOnSuggestTerminate(2);
  732.         3: //Clock moved back
  733.           FOnSuggestTerminate(3);
  734.       end;
  735.     end;
  736. end;
  737.  
  738. end.
  739.